home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog2.arj / COMMON.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  10.0 KB  |  352 lines
  1. (* ----------------------------------------------------------- *(
  2. **  COMMON.PAS -- Windows 3.1 common dialogs demonstration     **
  3. ** ----------------------------------------------------------- **
  4. **  This program demonstrates how to use the nine common       **
  5. **  dialogs in Windows 3.1 with Turbo Pascal for Windows. The  **
  6. **  program requires TPW 1.0 (patched for Windows 3.1) or you  **
  7. **  can use TPW 1.5. The program DOES NOT COMPILE with the     **
  8. **  original unpatched TPW 1.0.                                **
  9. ** ----------------------------------------------------------- **
  10. **       Copyright (c) 1992 by Tom Swan. Use as you wish       **
  11. )* ----------------------------------------------------------- *)
  12.  
  13. program Common;
  14.  
  15. {$R common.res}
  16.  
  17. uses WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg;
  18.  
  19. {$I common.inc}
  20.  
  21. const
  22.  
  23.   em_BadVersion = -100;
  24.  
  25. type
  26.  
  27.   TColorArray = array[0 .. 15] of TColorRef;
  28.  
  29.   TCommApp = object(TApplication)
  30.     procedure Error(ErrorCode: Integer); virtual;
  31.     procedure InitInstance; virtual;
  32.     procedure InitMainWindow; virtual;
  33.   end;
  34.  
  35.   PCommWin = ^TCommWin;
  36.   TCommWin = object(TWindow)
  37.   {- Color dialog data members }
  38.     Color: TColorRef;  { Selected color }
  39.     AColors: TColorArray;  { Custom color array }
  40.   {- Font dialog data member }
  41.     Font: TLogFont;  { Logical font }
  42.   {- File dialog data members }
  43.     Filename: array[0 .. 255] of Char;  { Current file name }
  44.     FilterStr: array[0 .. 80] of Char;  { File filter list }
  45.     FilterIndex: Integer;  { Number of filter for dlg list box }
  46.   {- Find and replace dialog data members }
  47.     HFindDLG: HWND;
  48.     FindStr: array[0 .. 40] of Char;
  49.     ReplaceStr: array[0 .. 40] of Char;
  50.     FR: TFindReplace;
  51.   {- Constructor }
  52.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  53.   {- Inherited methods }
  54.     function GetClassName: PChar; virtual;
  55.     procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  56.   {- Message-response methods (menu commands) }
  57.     procedure CMFileExit(var Msg: TMessage);
  58.       virtual cm_First + cm_FileExit;
  59.     procedure CMDialogsColor(var Msg: TMessage);
  60.       virtual cm_First + cm_DialogsColor;
  61.     procedure CMDialogsFont(var Msg: TMessage);
  62.       virtual cm_First + cm_DialogsFont;
  63.     procedure CMDialogsOpen(var Msg: TMessage);
  64.       virtual cm_First + cm_DialogsOpen;
  65.     procedure CMDialogsSaveAs(var Msg: TMessage);
  66.       virtual cm_First + cm_DialogsSaveAs;
  67.     procedure CMDialogsPrint(var Msg: TMessage);
  68.       virtual cm_First + cm_DialogsPrint;
  69.     procedure CMDialogsFind(var Msg: TMessage);
  70.       virtual cm_First + cm_DialogsFind;
  71.     procedure CMDialogsReplace(var Msg: TMessage);
  72.       virtual cm_First + cm_DialogsReplace;
  73.     procedure CMHelpAbout(var Msg: TMessage);
  74.       virtual cm_First + cm_HelpAbout;
  75.   end;
  76.  
  77. { TCommApp }
  78.  
  79. {- Respond to startup errors }
  80. procedure TCommApp.Error(ErrorCode: Integer);
  81. begin
  82.   if Status = em_BadVersion then
  83.     MessageBox(0, 'Requires Windows 3.1 or later',
  84.       'Version Error', mb_ApplModal or mb_IconStop or mb_Ok)
  85.   else
  86.     TApplication.Error(ErrorCode);
  87. end;
  88.  
  89. {- Detect Windows version number. Halt if < 3.1. }
  90. procedure TCommApp.InitInstance;
  91. var
  92.   Version: LongInt;
  93.   MajorRev, MinorRev: Byte;
  94.   Okay: Boolean;
  95. begin
  96.   Version := GetVersion;
  97.   MajorRev := LOBYTE(LOWORD(Version));
  98.   MinorRev := HIBYTE(LOWORD(Version));
  99.   if (MajorRev < 3) then Okay := false else
  100.   if (MajorRev = 3) then Okay := (MinorRev >= 1) else
  101.   if (MajorRev > 3) then Okay := true;  { I hope! }
  102.   if Okay then
  103.     TApplication.InitInstance
  104.   else
  105.     Status := em_BadVersion;
  106. end;
  107.  
  108. {- Initialize the application's window }
  109. procedure TCommApp.InitMainWindow;
  110. begin
  111.   MainWindow := New(PCommWin, Init(nil, 'Common Dialogs'));
  112. end;
  113.  
  114. { TCommWin }
  115.  
  116. {- Initialize the application's window object }
  117. constructor TCommWin.Init(AParent: PWindowsObject; ATitle:PChar);
  118. var
  119.   I: Integer;
  120. begin
  121.   TWindow.Init(AParent, ATitle);
  122.   with Attr do
  123.   begin
  124.     Menu := LoadMenu(HInstance, PChar(id_Menu));
  125.     X := GetSystemMetrics(sm_CXScreen) div 8;
  126.     Y := GetSystemMetrics(sm_CYScreen) div 8;
  127.     H := Y * 6;
  128.     W := X * 6;
  129.   end;
  130. {- Initialize color dialog data members }
  131.   Color := RGB(0, 0, 0);  { Initial color }
  132.   for I := 0 to 15 do     { Set custom colors to white }
  133.     AColors[I] := RGB(255, 255, 255);
  134. {- Initialize logical font data members }
  135.   FillChar(Font, sizeof(Font), #0);
  136. {- Initialize file name and list-box filters (wild cards) }
  137.   Filename[0] := #0;
  138.   if LoadString(HInstance, str_FileFilters, FilterStr,
  139.                 Sizeof(FilterStr)) = 0 then
  140.     FilterStr[0] := #0
  141.   else
  142.     for I := 0 to StrLen(FilterStr) do
  143.       if FilterStr[I] = '|' then
  144.         FilterStr[I] := #0;
  145.   FilterIndex := 1;
  146. {- Initialize find and replace data members }
  147.   HFindDlg := 0;
  148.   FindStr[0] := #0;
  149.   ReplaceStr[0] := #0;
  150. end;
  151.  
  152. {- Return unique name for modified window class }
  153. function TCommWin.GetClassName: PChar;
  154. begin
  155.   GetClassName := 'TCommWin';
  156. end;
  157.  
  158. {- Modify window class to use custom icon }
  159. procedure TCommWin.GetWindowClass(var AWndClass: TWndClass);
  160. begin
  161.   TWindow.GetWindowClass(AWndClass);
  162.   AWndClass.HIcon := LoadIcon(HInstance, PChar(id_Icon));
  163. end;
  164.  
  165. {- Exit program by closing the main window }
  166. procedure TCommWin.CMFileExit(var Msg: TMessage);
  167. begin
  168.   CloseWindow;
  169. end;
  170.  
  171. {- DIALOG #1: Common color dialog }
  172. procedure TCommWin.CMDialogsColor(var Msg: TMessage);
  173. var
  174.   CC: TChooseColor;
  175.   TempColors: TColorArray;
  176. begin
  177.   FillChar(CC, Sizeof(CC), #0);
  178.   TempColors := AColors;  { Copy current color array }
  179.   with CC do
  180.   begin
  181.     lStructSize := Sizeof(TChooseColor);
  182.     hwndOwner := HWindow;
  183.     Flags := cc_RGBInit or cc_FullOpen;
  184.     rgbResult := Color;
  185.     lpCustColors := @TempColors;
  186.   end;
  187.   if (ChooseColor(CC)) then with CC do
  188.   begin
  189.     Color := rgbResult;  { Use this color to draw }
  190.     AColors := TempColors;  { Save custom color array }
  191.   end;
  192. end;
  193.  
  194. {- DIALOG #2: Common font-selection dialog }
  195. procedure TCommWin.CMDialogsFont(var Msg: TMessage);
  196. var
  197.   CF: TChooseFont;
  198.   TempFont: TLogFont;
  199. begin
  200.   FillChar(CF, Sizeof(CF), #0);
  201.   TempFont := Font;  { Copy current font }
  202.   with CF do
  203.   begin
  204.     lStructSize := SizeOf(TChooseFont);
  205.     HWndOwner := HWindow;
  206.     Flags := cf_InitToLogFontStruct or cf_Both or cf_Effects;
  207.     lpLogFont := @TempFont;
  208.     rgbColors := Color;  { Selected by Color dialog }
  209.   end;
  210.   if ChooseFont(CF) then with CF do
  211.   begin
  212.     Font := lpLogFont^;  { Use this font for text }
  213.   end;
  214. end;
  215.  
  216. {- DIALOG #3: Common file-open dialog }
  217. procedure TCommWin.CMDialogsOpen(var Msg: TMessage);
  218. var
  219.   FN: TOpenFilename;
  220.   Tempname: array[0 .. 255] of Char;
  221. begin
  222.   FillChar(FN, Sizeof(FN), #0);
  223.   StrCopy(Tempname, Filename);  { Copy current file name }
  224.   with FN do
  225.   begin
  226.     lStructSize := SizeOf(TOpenFilename);
  227.     hWndOwner := HWindow;
  228.     Flags := ofn_PathMustExist or ofn_FileMustExist;
  229.     lpstrFile := Tempname;  { Address current file name }
  230.     nMaxFile := Sizeof(Filename);
  231.     lpstrFilter := FilterStr;  { Address file filters }
  232.     nFilterIndex := FilterIndex;  { Filter for list box }
  233.   end;
  234.   if GetOpenFileName(FN) then with FN do
  235.   begin
  236.     StrCopy(Filename, lpstrFile);  { Save selected file name }
  237.     FilterIndex := nFilterIndex;  { Save selected filter # }
  238.   end;
  239. end;
  240.  
  241. {- DIALOG #4: Common file-save-as dialog }
  242. procedure TCommWin.CMDialogsSaveAs(var Msg: TMessage);
  243. var
  244.   FN: TOpenFilename;
  245.   Tempname: array[0 .. 255] of Char;
  246. begin
  247.   FillChar(FN, Sizeof(FN), #0);
  248.   StrCopy(Tempname, Filename);  { Copy current file name }
  249.   with FN do
  250.   begin
  251.     lStructSize := SizeOf(TOpenFilename);
  252.     hWndOwner := HWindow;
  253.     Flags := ofn_OverwritePrompt;
  254.     lpstrFile := Tempname;  { Address current file name }
  255.     nMaxFile := Sizeof(Filename);
  256.     lpstrFilter := FilterStr;  { Address file filters }
  257.     nFilterIndex := FilterIndex;  { Filter for list box }
  258.   end;
  259.   if GetSaveFileName(FN) then with FN do
  260.   begin
  261.     StrCopy(Filename, lpstrFile);  { Save selected file name }
  262.     FilterIndex := nFilterIndex;  { Save selected filter # }
  263.   end;
  264. end;
  265.  
  266. {- DIALOGS #5-7: Common printer, setup, and options dialogs }
  267. procedure TCommWin.CMDialogsPrint(var Msg: TMessage);
  268. var
  269.   PD: TPrintDlg;
  270. begin
  271.   FillChar(PD, Sizeof(PD), #0);
  272.   with PD do
  273.   begin
  274.     lStructSize := Sizeof(TPrintDlg);
  275.     hWndOwner := HWindow;
  276.     Flags := pd_ReturnDC;  { pd_PrintSetup for setup dlg }
  277.   end;
  278.   if PrintDlg(PD) then
  279.   begin
  280.   {- ... Print using PD.hDC device context. }
  281.     DeleteDC(PD.hDC);
  282.     if PD.hDevMode <> 0 then
  283.       GlobalFree(PD.hDevMode);
  284.     if PD.hDevNames <> 0 then
  285.       GlobalFree(PD.hDevNames);
  286.   end;
  287. end;
  288.  
  289. {- DIALOG #8: Common find-text dialog }
  290. procedure TCommWin.CMDialogsFind(var Msg: TMessage);
  291. begin
  292.   if HFindDLG <> 0 then
  293.   begin
  294.     SendMessage(HFindDLG, wm_Close, 0, 0);
  295.     HFindDLG := 0;
  296.   end;
  297.   FillChar(FR, Sizeof(FR), #0);
  298.   with FR do
  299.   begin
  300.     lStructSize := Sizeof(TFindReplace);
  301.     hwndOwner := HWindow;
  302.     lpstrFindWhat := FindStr;
  303.     wFindWhatLen := Sizeof(FindStr);
  304.   end;
  305.   HFindDLG := FindText(FR)
  306. end;
  307.  
  308. {- DIALOG #9: Common replace-text dialog }
  309. procedure TCommWin.CMDialogsReplace(var Msg: TMessage);
  310. begin
  311.   if HFindDLG <> 0 then
  312.   begin
  313.     SendMessage(HFindDLG, wm_Close, 0, 0);
  314.     HFindDLG := 0;
  315.   end;
  316.   FillChar(FR, Sizeof(FR), #0);
  317.   with FR do
  318.   begin
  319.     lStructSize := Sizeof(FR);
  320.     hwndOwner := HWindow;
  321.     lpstrFindWhat := FindStr;
  322.     wFindWhatLen := Sizeof(FindStr);
  323.     lpstrReplaceWith := ReplaceStr;
  324.     wReplaceWithLen := Sizeof(ReplaceStr);
  325.   end;
  326.   HFindDLG := ReplaceText(FR);
  327. end;
  328.  
  329. {- Display this program's about-box dialog }
  330. procedure TCommWin.CMHelpAbout(var Msg: TMessage);
  331. var
  332.   Dialog: TDialog;
  333. begin
  334.   Dialog.Init(@Self, PChar(id_About));
  335.   Dialog.Execute;
  336.   Dialog.Done;
  337. end;
  338.  
  339. var
  340.   CommApp: TCommApp;
  341. begin
  342.   CommApp.Init('Common');
  343.   CommApp.Run;
  344.   CommApp.Done
  345. end.
  346.  
  347.  
  348. (*
  349. // Copyright (c) 1992 by Tom Swan. All rights reserved
  350. // Revision 1.00    Date: 05/15/1992   Time: 9:00 am
  351. *)
  352.